home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The PC-SIG Library 10
/
The PC-Sig Library - Shareware for the IBM PC and Compatibles (PC-SIG)(Tenth Edition Disks 1-2804)(1991).iso
/
PC_SIGCD
/
06
/
8
/
DISK0685.ZIP
/
FORTH.ARC
/
GR.SCR
< prev
next >
Wrap
Text File
|
1986-02-12
|
12KB
|
1 lines
Graphics utilities for the IBM-PC ( utilities, terminal graphics: GOTOXY, HOME, GRAPHICS, MONO) FORTH DEFINITIONS DECIMAL : GOTOXY 0 ROT ROT SWAP LOCATE ; : HOME 0 0 0 LOCATE ; HEX ( Select color graphics or monochrome display ) : GRAPHICS 40 10 L@ 0CF AND 020 OR 40 10 L! 6 MODE! ; : MONO 40 10 L@ 0CF AND 030 OR 40 10 L! 7 MODE! ; DECIMAL : PRINTER-ONLY -1 PRINTER ! ; : PRINTER-ALSO 1 PRINTER ! ; : PRINTER-OFF 0 PRINTER ! ; ;S ( graphics: !DOT ) ( Ray Duncan, Dr. Dobbs' #69 ) FORTH DEFINITIONS HEX B800 CONSTANT MAP 0 VARIABLE BIT-TABLE -2 ALLOT 80 C, 40 C, 20 C, 10 C, 8 C, 4 C, 2 C, 1 C, : !DOT OVER 7 AND BIT-TABLE + C@ >R DUP 1 AND IF 2000 ELSE 0 ENDIF SWAP 2 / 50 * + SWAP 8 / + MAP SWAP 2DUP LC@ R> OR ROT ROT LC! ; : PICK 2 * SP@ + @ ; 0 VARIABLE TEMP : ROLL 2 * >R DUP TEMP ! SP@ DUP 2- R CMOVE TEMP @ SP@ R> + ! ; --> ( graphics, cont.: LINE ) DECIMAL 0 VARIABLE INCR 2 ALLOT : 4DUP 4 PICK 4 PICK 4 PICK 4 PICK ; : 2SWAP 4 ROLL 4 ROLL ; : LINE 4DUP ROT - ABS ROT ROT SWAP - ABS < IF 4 PICK 3 PICK > IF 2SWAP ENDIF 4DUP ROT - ROT ROT SWAP - SWAP 1000 M* ROT M/ S->D INCR 2! DROP DROP SWAP 1000 M* 4 ROLL 4 ROLL SWAP DO 2DUP 1000 M/ SWAP DROP I SWAP !DOT INCR 2@ D+ LOOP ELSE 3 PICK 2 PICK > IF 2SWAP ENDIF 4DUP ROT - ROT ROT SWAP - --> ( graphics: LINE, cont. ) 1000 M* ROT M/ S->D INCR 2! DROP SWAP DROP ROT 1000 M* 4 ROLL 4 ROLL SWAP DO 2DUP 1000 M/ SWAP DROP I !DOT INCR 2@ D+ LOOP ENDIF DROP DROP ; ;S ( graphics: BOX ) FORTH DEFINITIONS DECIMAL 1 VARIABLE DENSITY : HLINE ( X Y L -- ) >R OVER DUP R> + SWAP DO I OVER !DOT DENSITY @ +LOOP DROP DROP ; 0 VARIABLE X1 0 VARIABLE X2 0 VARIABLE Y1 0 VARIABLE Y2 : BOX 4 PICK 3 PICK < IF Y2 ! X2 ! Y1 ! X1 ! ELSE Y1 ! X1 ! Y2 ! X2 ! THEN X1 @ Y1 @ X2 @ X1 @ - HLINE X2 @ Y1 @ X2 @ Y2 @ LINE X1 @ Y2 @ X2 @ X1 @ - HLINE X1 @ Y2 @ X1 @ Y1 @ LINE ; ;S ( Turtle graphics: LEFT, RIGHT, MOVE ) : WITHIN ( x i f -- x' ; insures that i<=x<=f ) 3 PICK MIN ROT ROT MAX MAX ; 300 VARIABLE TURX 100 VARIABLE TURY 0 VARIABLE TDIR 0 VARIABLE TDN? : LEFT TDIR @ + 360 MOD TDIR ! ; : RIGHT MINUS 360 + LEFT ; : +GOTO TURY @ SWAP - 0 199 WITHIN TURY ! TURX @ + 0 639 WITHIN TURX ! ; : MOVE >R TURX @ TURY @ TDIR @ COS R 10000 */ 64 25 */ TDIR @ SIN R> 10000 */ +GOTO TURX @ TURY @ LINE ; ( MX-80 graphics support ) : ESC 27 EMIT EMIT ; ( c -- ;send <esc><c> ) : GRMODE0 75 ESC 256 /MOD SWAP EMIT EMIT ; ( n -- ;0<n<481 ) : GRMODE1 76 ESC 256 /MOD SWAP EMIT EMIT ; ( n -- ;0<n<960 ) : DOTS/LINE 65 ESC EMIT ; ( n -- ;set spacing to n/72" ) : PRESET 64 ESC ; ( reset printer ) : ?ESC ?TERMINAL IF KEY 27 = IF PRESET CR 1 PRINTER ! ." PRINT ABORTED..." (ABORT) THEN THEN ; --> ( MX-80 graphics screen dump support ) HEX B800 CONSTANT HIRES-SEG DECIMAL 8 STRING HBUF 8 STRING VBUF 0 VARIABLE BITS -2 ALLOT 128 C, 64 C, 32 C, 16 C, 8 C, 4 C, 2 C, 1 C, : HIRES-MAP ( row col -- seg: addr ;row 0-199 col 0-79 ) OVER 2 / 80 * + SWAP 1 AND 8192 * + HIRES-SEG SWAP ; : GETBYTE ( row col -- ;get 8 bytes at row,col into VBUF ) SWAP 8 * DUP 8 + SWAP DO I OVER HIRES-MAP LC@ I 8 MOD VBUF C! LOOP DROP ; --> ( MX-80 graphics screen dump support ) : J RP@ 6 + @ ; : PICK 2 * SP@ + @ ; : ?BIT BITS + C@ AND ; : SETBIT DUP C@ ROT BITS + C@ OR SWAP C! ; : INVERT ( -- ; inverts bytes for printing horizontally ) 0 HBUF 8 ERASE 8 0 DO I VBUF C@ 8 0 DO DUP I ?BIT IF J I HBUF SETBIT THEN LOOP DROP LOOP ; --> ( MX-80 horizontal screen dump ) : MARGIN DUP GRMODE1 0 DO 0 EMIT LOOP ; ( n -- ;space n cols ) : HPRTBYTE ( -- ;send HBUF - 8 columns - to MX ) 8 0 DO I HBUF + C@ EMIT LOOP ; : PRTLINE ( line# -- ;send 80 'characters' to printer ) 160 MARGIN 640 GRMODE1 80 0 DO DUP I GETBYTE INVERT HPRTBYTE LOOP DROP ?ESC CR ; : HPRTSCR ( -- ;graphics dump : 3 by 5.5 inches ) -1 PRINTER ! CR 8 DOTS/LINE 25 0 DO I PRTLINE LOOP PRESET 0 PRINTER ! ; --> ( MX-80 vertical screen dump ) : PRTBYTE ( -- ;send VBUF to MX. 4 times because of mode 1 ; reversed because of vertical orientation ) 0 7 DO I VBUF C@ DUP 2DUP EMIT EMIT EMIT EMIT -1 +LOOP ; : PRTCOL ( n -- ;send one column [25 rows] to MX; also rev'sd) 80 MARGIN 800 GRMODE1 0 24 DO I OVER GETBYTE PRTBYTE -1 +LOOP ?ESC CR DROP ; : PRTSCR ( -- ;vertical graphics dump : 7 by 9 inches ) -1 PRINTER ! 8 DOTS/LINE CR CR CR CR 80 0 DO I PRTCOL LOOP PRESET 0 PRINTER ! ; ;S
